home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / run.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  259 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; A little interpreter.
  5.  
  6. (define (eval form p)
  7.   (eval-forms (list form) p #f))
  8.  
  9. ; Programs
  10.  
  11. (define (eval-forms forms p file)
  12.   (eval-nodes (scan-forms forms p file)
  13.           (package->environment p)
  14.           file))
  15.  
  16. (define (eval-nodes nodes env file)
  17.   (if (not (null? nodes))
  18.       (run-nodes nodes (bind-source-file-name file env))))
  19.  
  20. (define (run-nodes nodes env)
  21.   (do ((nodes nodes (cdr nodes)))
  22.       ((null? (cdr nodes))
  23.        (run-node (car nodes) env))
  24.     (run-node (car nodes) env)))
  25.  
  26. (define (run-node node env)
  27.   (cond ((define-node? node)
  28.      (let* ((form (node-form node))
  29.         (loc (binding-place (lookup env (cadr form))))
  30.         (value (run (caddr form) env)))
  31.        (set-location-defined?! loc #t)
  32.        (set-contents! loc value)))
  33.     ((not (define-syntax-node? node))
  34.      (run node env))))
  35.  
  36.  
  37. ; Main dispatch for a single expression.
  38.  
  39. (define (run exp env)
  40.   (let ((node (classify exp env)))
  41.     ((operator-table-ref interpreters (node-operator-id node)) node env)))
  42.  
  43. (define interpreters
  44.   (make-operator-table (lambda (node env)
  45.              (run-call (node-form node) env))))
  46.  
  47. (define (define-interpreter name type proc)
  48.   (operator-define! interpreters name type proc))
  49.  
  50. (define-interpreter 'name #f
  51.   (lambda (node env)
  52.     (let ((binding (name-node-binding node env)))
  53.       (cond ((binding? binding)
  54.          (if (and (compatible-types? (binding-type binding) value-type)
  55.               (location? (binding-place binding)))
  56.          (let ((loc (binding-place binding)))
  57.            (if (location-defined? loc)
  58.                (contents loc)
  59.                (error "uninitialized variable" (schemify node env))))
  60.          (error "invalid variable reference" (schemify node env))))
  61.         ((unbound? binding)
  62.          (error "unbound variable" (schemify node env)))
  63.         (else
  64.          (error "peculiar binding" node binding))))))
  65.  
  66. (define (name-node-binding node env)
  67.   (or (node-ref node 'binding)
  68.       (lookup env (node-form node))))
  69.  
  70. (define-interpreter 'literal #f
  71.   (lambda (node env)
  72.     (node-form node)))
  73.  
  74. (define-interpreter 'call #f
  75.   (lambda (node env)
  76.     (run-call (node-form node) env)))
  77.  
  78. (define (run-call exp env)
  79.   (let ((proc (run (car exp) env)))    ;Doing this first aids debugging
  80.     (apply proc
  81.        (map (lambda (arg-exp)
  82.           (run arg-exp env))
  83.         (cdr exp)))))
  84.  
  85. (define-interpreter 'quote syntax-type
  86.   (lambda (node env)
  87.     (cadr (node-form node))))
  88.  
  89. (define-interpreter 'lambda syntax-type
  90.   (lambda (node env)
  91.     (let ((exp (node-form node)))
  92.       (make-interpreted-closure (cadr exp) (cddr exp) env))))
  93.  
  94. (define (make-interpreted-closure formals body env)
  95.   (lambda args
  96.     (run-body body (bind-vars formals args env))))
  97.  
  98. (define (run-body body env)
  99.   (scan-body
  100.       body
  101.       env
  102.       (lambda (defs exps)
  103.     (if (null? defs)
  104.         (run-begin exps env)
  105.         (run-letrec (map (lambda (def) (cdr (node-form def))) defs)
  106.             exps
  107.             env)))))
  108.  
  109.  
  110. (define-interpreter 'begin syntax-type
  111.   (lambda (node env)
  112.     (let ((exp (node-form node)))
  113.       (run-begin (cdr exp) env))))
  114.  
  115. (define (run-begin exp-list env)
  116.   (if (null? exp-list)
  117.       (syntax-error "null begin")
  118.       (let loop ((exp-list exp-list))
  119.     (if (null? (cdr exp-list))
  120.         (run (car exp-list) env)
  121.         (begin (run (car exp-list) env)
  122.            (loop (cdr exp-list)))))))
  123.  
  124. (define-interpreter 'set! syntax-type
  125.   (lambda (node env)
  126.     (let* ((exp (node-form node))
  127.        (probe (name-node-binding (classify (cadr exp) env) env)))
  128.       (cond ((and (binding? probe)
  129.           (location? (cdr probe)))
  130.          (if (and (location-defined? (binding-place probe))
  131.               (variable-type? (binding-type probe)))
  132.          (set-contents! (cdr probe) (run (caddr exp) env))
  133.          (error "invalid assignment" (schemify node env))))
  134.         ((unbound? probe) (error "unbound variable" exp))
  135.         (else (error "peculiar assignment" exp))))))
  136.  
  137. (define-interpreter 'if syntax-type
  138.   (lambda (node env)
  139.     (let ((exp (node-form node)))
  140.       (if (null? (cdddr exp))
  141.       (if (run (cadr exp) env)
  142.           (run (caddr exp) env))    ;hack
  143.       (if (run (cadr exp) env)
  144.           (run (caddr exp) env)
  145.           (run (cadddr exp) env))))))
  146.  
  147. ; (reverse specs) in order to try to catch unportabilities
  148.  
  149. (define-interpreter 'letrec syntax-type
  150.   (lambda (node env)
  151.     (let ((exp (node-form node)))
  152.       (run-letrec (cadr exp) (cddr exp) env))))
  153.  
  154. (define (run-letrec specs body env)
  155.   (let* ((bindings (map (lambda (spec)
  156.               (make-binding usual-variable-type
  157.                     (make-undefined-location (car spec))
  158.                     #f))
  159.             specs))
  160.      (env (bind (map car specs)
  161.             bindings
  162.             env)))
  163.     (for-each (lambda (binding val)
  164.         (let ((loc (binding-place binding)))
  165.           (set-location-defined?! loc #t)
  166.           (set-contents! loc val)))
  167.           bindings
  168.           (map (lambda (spec) (run (cadr spec) env)) specs))
  169.     (run-body body env)))
  170.  
  171.  
  172. (let ((bad (lambda (node env)
  173.          (error "not valid in expression context" (node-form node)))))
  174.   (define-interpreter 'define syntax-type bad)
  175.   (define-interpreter 'define-syntax syntax-type bad))
  176.  
  177.  
  178. ; Primitive procedures
  179.  
  180. (define-interpreter 'primitive-procedure syntax-type
  181.   (lambda (node env)
  182.     (let ((name (cadr (node-form node))))
  183.       (or (table-ref primitive-procedures name)
  184.       (lambda args
  185.         (error "unimplemented primitive procedure" name))))))
  186.  
  187. (define primitive-procedures (make-table))
  188.  
  189. (define (define-a-primitive name proc)
  190.   (table-set! primitive-procedures name proc)
  191.   (define-interpreter name any-procedure-type
  192.     (lambda (node env)
  193.       (apply proc (map (lambda (arg) (run arg env))
  194.                (cdr (node-form node)))))))
  195.  
  196. (define-a-primitive 'unspecific
  197.   (lambda () (if #f #f)))        ;For COND
  198.  
  199. (define-syntax define-some-primitives
  200.   (syntax-rules ()
  201.     ((define-some-primitives name ...)
  202.      (begin (define-a-primitive 'name name) ...))))
  203.  
  204. (define-some-primitives
  205.   + - * quotient remainder = <
  206.   eq? car cdr cons
  207.   pair?
  208.   vector? vector-ref string? string-ref
  209.   symbol?
  210.   char<? char=?)
  211.  
  212.  
  213. ; --------------------
  214. ; Environments
  215.  
  216. (define (bind-var name arg env)
  217.   (let ((loc (make-undefined-location name)))
  218.     (set-location-defined?! loc #t)
  219.     (set-contents! loc arg)
  220.     (bind1 name (make-binding usual-variable-type loc #f) env)))
  221.  
  222. (define (bind-vars names args env)
  223.   (cond ((null? names)
  224.      (if (null? args)
  225.          env
  226.          (error "too many arguments" args)))
  227.     ((not (pair? names))
  228.      (bind-var names args env))
  229.     ((null? args)
  230.      (error "too few arguments" names))
  231.     (else
  232.      (bind-var (car names) (car args)
  233.            (bind-vars (cdr names) (cdr args) env)))))
  234.  
  235.  
  236. ; LOAD
  237.  
  238. (define (load filename . package-option)
  239.   (load-into filename (if (null? package-option)
  240.               (interaction-environment)
  241.               (car package-option))))
  242.  
  243. (define (load-into filename package)
  244.   (eval-nodes (scan-file filename package)
  245.           (package->environment package)
  246.           filename))
  247.  
  248. (define (load-quietly filename package)
  249.   (eval-nodes (really-scan-file filename package #f)    ; No noise. For scsh.
  250.           (package->environment package)
  251.           filename))
  252.  
  253.  
  254. (define (eval-from-file forms p file)    ;Scheme 48 internal thing
  255.   (eval-forms forms p file))
  256.  
  257.  
  258. ; (scan-structures (list s) (lambda (p) #t) (lambda (stuff) #f))
  259.